PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/miscuni.com/MESSAGES.PAS

Pascal/Delphi Source File | 1989-05-25 | 13.4 KB | 368 lines

{.he Popup Message Module - %F}
(**************************************************************************)
(*                              Messages                                  *)
(*                                                                        *)
(*  Author:  Geoffrey Moehrke                                             *)
(*  Date:    May 25, 1989                                                 *)
(*                                                                        *)
(*  Purpose: Put variable line message window on screen. Messages are     *)
(*           passed with embedded formatting codes to determine number of *)
(*           lines, changes in screen attributes, justification, etc.     *)
(*                                                                        *)
(*  Source:  F:\TP\UNIT\MESSAGES.PAS                                      *)
(**************************************************************************)
Unit Messages;

Interface

  Uses TPCRT,

       {$IFDEF UseClock}
       TPClock,
       {$ENDIF}

       TPWindow,
       TPString,
       Stacks;

  Const CmdPre = #0;                    { Itentifies beginning of embedded }
                                        { command sequence within a string }

{ The following command sequences are valid within message strings         }

        NewLnCmd  = #0#1;               { Start following text on new line }
        TitleCmd  = #0#6;               { Put a header on the message      }
                                        { text (and valid commands) of     }
                                        { header should be enclosed by     }
                                        { TitleCmd                         }
        DelayCmd  = #0#12;              { DelayCmd + #n - delay n seconds  }
                                        { or until key pressed - actual    }
                                        { time will depend somewhat on     }
                                        { the processor, but will be close }
                                        { to specified.                    }

{  The following command sequences are valid within message window titles  }

        BeepCmd  = #0#7;                { Beep when displaying             }
        RowCmd   = #0#8;                { RowCmd + #n -  Set top row to n  }
                                        { if possible.                     }
        ColCmd   = #0#9;                { ColCmd + #n - Set first col to n }
                                        { if possible                      }
        PauseCmd = #0#10;               { Pause until key pressed          }
        LeaveCmd = #0#11;               { Leave window up until RemoveMsg  }
                                        { is called                        }
        LeftCmd   = #0#3;               { Left justify message in window   }
        RightCmd  = #0#4;               { Right justify message in window  }
        CenterCmd = #0#5;               { Center message in window         }


  type MsgStr = String;
       JustifyType = (Left, Right, Cntr);
       CStr = String[3];

   type
       ReadKeyFunc = Function : Word;
       LoopProc = Procedure;

{ The following are the default variables for messages                     }

  Var   MsgWinTopRow,                   { Try to place top of window at    }
                                        { this row - will move up if not   }
                                        { room.  0 for centered window.    }

        MsgWinFirstCol: byte;           { Try to place left edge of window }
                                        { at this column - will move left  }
                                        { if not room.  0 for centered win.}

        MsgWinColor: FlexAttrs;         { Default message window colors    }
        MsgFrameColor,
        MsgTitleColor,
        MsgWinDefLen : Byte;

        MsgJust : JustifyType;          { Default justification - usually  }
                                        { Cntr.                            }

        MsgDisposeCh : boolean;         { When waiting for keypress in     }
                                        { paused message window - dispose  }
                                        { the key pressed.                 }

        MsgReadKW : ReadKeyFunc;        { User definable read key function  }
        MsgLoopProc : LoopProc;         { User definable proc. to call while}
                                        { waiting for key                   }

{  Message strings are written using TPCRT's FlexWriteWindow commands      }
{  attributes for these message strings can be changed by inserting        }
{  the appropriate control characters into the strings.                    }

  procedure SetMsgDefaults( WindowColor: FlexAttrs; FrameColor, TitleColor,
                            TopRow, TopCol: byte; Just: JustifyType );
    {-Change the default characteristics of message windows. }

  function CmdStr( Cmd: CStr; P:byte ): CStr;
    {-Compose a command string consisting of the command and the
      parameter byte converted to a char.}

  procedure Message( S : MsgStr );
    {-Message driver - displays S in a box formatted as specified. }

  procedure RemoveMsg;
    {-Remove message from screen if left on previously using LeaveCmd. }

{==========================================================================}
Implementation

   var MsgWindow : WindowPtr;
       MsgActive : Byte;
       MsgStack  : Stack;

procedure SetMsgDefaults( WindowColor: FlexAttrs; FrameColor, TitleColor,
                          TopRow, TopCol: byte; Just: JustifyType );
    {-Change the default characteristics of message windows. }

  begin
    MsgWinColor    := WindowColor;
    MsgFrameColor  := FrameColor;
    MsgTitleColor  := TitleColor;
    MsgWinTopRow   := TopRow;
    MsgWinFirstCol := TopCol;
    Msgjust := Just;
  end;

function CmdStr( Cmd: CStr; P:byte ): CStr;
    {-Compose a command string consisting of the command and the
      parameter byte converted to a char.}

  begin
    CmdStr := Cmd + Char(P);
  end;

  function MsgLength( S : String) : byte;
    {-Return the display length of a string possibly containing containing
      attribute commands                                                    }

    var I, Temp: byte;

  begin
    Temp := 0;
    for I := 1 to Length(S) do
      if Not (S[I] In [^A, ^B, ^C]) then
        inc(Temp);
    MsgLength := Temp;
  end;

{$F+}
  procedure NilLoopProc;
    { -Default loop procedure - does absolutely nothing }
  begin
  end;
{$F-}

  procedure Message( S : MsgStr );
    {-Message driver - displays S in a box formatted as specified. }

    var WinColor   : FlexAttrs;
        FrameColor,
        TitleColor,
        TopRow,
        FirstCol,
        DelaySec,
        CmdPos,
        TitleStart,
        TitleEnd,
        NumLines,
        WinLength,
        OldLen,
        I           : byte;
        DelayCount  : integer;
        Just        : JustifyType;
        H           : string;
        MsgLines    : array[1..10] of string[80];
        LeaveWin,
        Pause,
        BeepOn      : boolean;

  begin
    Inc(MsgActive);
    LeaveWin := False;
    Pause := False;
    BeepOn := False;
    DelaySec := 0;
    WinColor := MsgWinColor;
    FrameColor := MsgFrameColor;
    TitleColor := MsgTitleColor;   { Set all parameters to default values }
    TopRow := MsgWinTopRow;
    FirstCol := MsgWinFirstCol;
    Just := MsgJust;
    H := '';
    TitleStart := Pos(TitleCmd,S); { Find window title if exists             }
    if TitleStart <> 0 then begin
        Delete(S,TitleStart,Length(TitleCmd));
        TitleEnd := Pos(TitleCmd,S);
        if TitleEnd = 0 then TitleEnd := Length(S);
        Delete(S,TitleEnd,Length(TitleCmd));
        H := Copy(S,TitleStart,TitleEnd-TitleStart);
        Delete(S,TitleStart,TitleEnd-TitleStart);
    end;
    CmdPos := Pos(RowCmd,H);            { Look for command to set top row    }
    If CmdPos <> 0 then begin
      TopRow := byte(H[CmdPos+Length(RowCmd)]); { Interpret command          }
      Delete(H,CmdPos,Length(RowCmd)+1);        { Remove it from string      }
    end;
    CmdPos := Pos(ColCmd,H);          { Look for command to set 1st col      }
    If CmdPos <> 0 then begin
      FirstCol := byte(H[CmdPos+Length(ColCmd)]);{ Interpret command         }
      Delete(H,CmdPos,Length(ColCmd)+1);        { Remove it from string      }
    end;
    CmdPos := Pos(DelayCmd,H);        { Look for command to set delay time   }
    If CmdPos <> 0 then begin
      DelaySec := byte(H[CmdPos+Length(DelayCmd)]);{ Interpret command        }
      Delete(H,CmdPos,Length(DelayCmd)+1);      { Remove it from string      }
    end;
    CmdPos := Pos(LeaveCmd,H);         { Look for command to leave window    }
    if CmdPos <> 0 then begin
      LeaveWin := True;
      Delete(H,CmdPos,Length(LeaveCmd));
    end;
    CmdPos := Pos(PauseCmd,H);         { Look for command to pause           }
    if CmdPos <> 0 then begin
      Pause := True;
      Delete(H,CmdPos,Length(PauseCmd));
    end;
    CmdPos := Pos(BeepCmd,H);          { Look for command to beep            }
    if CmdPos <> 0 then begin
      BeepOn := True;
      Delete(H,CmdPos,Length(BeepCmd));
    end;
    CmdPos := Pos(LeftCmd,H);
    If CmdPos <> 0 then
      begin
        Just := Left;
        Delete(H,CmdPos,Length(LeftCmd));
      end;
    CmdPos := Pos(RightCmd,H);
    If CmdPos <> 0 then
      begin
        Just := Right;
        Delete(H,CmdPos,Length(RightCmd));
      end;
    CmdPos := Pos(CenterCmd,H);
    If CmdPos <> 0 then begin
        Just := Cntr;
        Delete(H,CmdPos,Length(CenterCmd));
    end;


    NumLines := 0;             { begin dividing message into lines           }
    CmdPos := Pos(NewLnCmd,S);
    If CmdPos = 0 then         { Single line message                         }
      begin
        MsgLines[1] := S;
        NumLines := 1;
        S := '';
      end
    else while CmdPos <> 0 do begin  { multiple line message                 }
      inc(NumLines);
      MsgLines[NumLines] := Trim(Copy(S,1,CmdPos-1));
      Delete(S,1,CmdPos+1);
      CmdPos := Pos(NewlnCmd,S);
    end;
    if S <> '' then begin
      inc(NumLines);
      MsgLines[NumLines] := TrimTrail(S);
    end;
    WinLength := MsgWinDefLen;        { Get max len for window sizing   }
    for I := 1 to NumLines do
      if MsgLength(MsgLines[I]) > WinLength then
        WinLength := MsgLength(MsgLines[I]);
    if MsgLength(H) > WinLength then
      WinLength := MsgLength(H);
    if WinLength > ScreenWidth then
      WinLength := ScreenWidth;{ dont let window exceed screen   }
    if FirstCol = 0 then
      FirstCol := 40 - (WinLength div 2)   { if not specified, center window }
    else while WinLength + FirstCol >= 80 do { else make sure it fits        }
      dec(FirstCol);
    If TopRow = 0 then
      TopRow := (ScreenHeight div 2) - (2+NumLines div 2);
    while TopRow+NumLines+1 > ScreenHeight do
      dec(TopRow);
    if not MakeWindow( MsgWindow, FirstCol, TopRow, FirstCol + WinLength+1,
                       TopRow+NumLines+1, True, True, False,
                       WinColor[0], FrameColor, TitleColor,H) then ;
    if DisplayWindow( MsgWindow ) then
      for I := 1 to NumLines do begin
        Case Just of
          Left  : MsgLines[I] := Pad( MsgLines[I],WinLength );
          Right : MsgLines[I] := LeftPad( MsgLines[I],WinLength );
          Cntr  : begin
                    MsgLines[I] := Center( MsgLines[I],WinLength);
                    Insert(CharStr(' ',(Length(MsgLines[I])-
                                   MsgLength(MsgLines[I])) Div 2), MsgLines[I],1);
                  end
        end;
        FlexWriteWindow(MsgLines[I],I,1,WinColor);
      end;
    GotoXY(MsgLength(TrimTrail(MsgLines[I]))+1,I );
    HiddenCursor;
    if BeepOn Then begin
      Sound(880); Delay(250); Nosound;
    end;
    DelayCount := 0;
    If DelaySec > 0 then
      repeat
        Delay(10);
        inc(DelayCount,10);
      until KeyPressed Or (DelayCount >= 1000 * DelaySec);
    if Pause then
      repeat
        MsgLoopProc;
      until keypressed;
    if MsgDisposeCh And Pause then
      I := byte( MsgReadKW );
    if not LeaveWin then
      begin
        MsgWindow := EraseTopWindow;
        DisposeWindow(MsgWindow);
        Dec(MsgActive)
      end
    else
      if Not Push( MsgStack, @MsgWindow ) then begin { If no room on stack }
        MsgWindow := EraseTopWindow;
        DisposeWindow(MsgWindow);
        Dec(MsgActive)
      end
  end;  { Msg }


  procedure RemoveMsg;
    {-Remove message from screen if left on previously usin LeaveCmd. }

    begin
      MsgWindow := WindowPtr(Pop(MsgStack)^);
      if SetTopWindow(MsgWindow) then
        begin
          MsgWindow := EraseTopWindow;
          DisposeWindow(MsgWindow);
          Dec(MsgActive);
        end;
    end;


  const
    DefMonoAtts : FlexAttrs = ($70, $07, $0F, $FF);
    DefColorAtts: FlexAttrs = ($4F, $4E, $4C, $40);

begin
  InitStack(MsgStack, SizeOf(WindowPtr) );
  MsgReadKW := ReadKeyWord;
  MsgLoopProc := NilLoopProc;
  MsgActive := 0;
  MsgDisposeCh := True;
  MsgWinDefLen := 0;
  if LastMode In [0, 2, 7] then
    SetMsgDefaults(DefMonoAtts, $70, $70, 0, 0,Cntr)
  Else
    SetMsgDefaults(DefColorAtts, $47, $47, 0, 0, Cntr);
end.  { Unit Messages }